home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpcsrc.lha / fpc / compiler / pp.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  15KB  |  535 lines
  1. {
  2.     $Id: pp.pas,v 1.1.1.1.2.2 1998/08/18 13:35:47 carl Exp $
  3.     Copyright (c) 1993-98 by Florian Klaempfl
  4.  
  5.     This program is free software; you can redistribute it and/or modify
  6.     it under the terms of the GNU General Public License as published by
  7.     the Free Software Foundation; either version 2 of the License, or
  8.     (at your option) any later version.
  9.  
  10.     This program is distributed in the hope that it will be useful,
  11.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13.     GNU General Public License for more details.
  14.  
  15.     You should have received a copy of the GNU General Public License
  16.     along with this program; if not, write to the Free Software
  17.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  ****************************************************************************}
  20.  
  21. {
  22.   possible compiler switches (* marks a currently required switch):
  23.   -----------------------------------------------------------------
  24.   USE_RHIDE           generates errors and warning in an format recognized
  25.                       by rhide
  26.   TP                  to compile the compiler with Turbo or Borland Pascal
  27.   GDB*                support of the GNU Debugger
  28.   I386                generate a compiler for the Intel i386+
  29.   M68K                generate a compiler for the M68000
  30.   MULLER              release special debug code of Pierre Muller
  31.                       (needs some extra units)
  32.   USEOVERLAY          compiles a TP version which uses overlays
  33.   EXTDEBUG            some extra debug code is executed
  34.   SUPPORT_MMX         only i386: releases the compiler switch
  35.                       MMX which allows the compiler to generate
  36.                       MMX instructions
  37.   EXTERN_MSG          Don't compile the msgfiles in the compiler, always
  38.                       use external messagefiles
  39.   BIG_ENDIAN          Target machine where compiler will run is
  40.                       a BIG ENDIAN machine (such as m68k)
  41.   -----------------------------------------------------------------
  42.   -----------------------------------------------------------------
  43.  
  44.   Required switches for a i386 compiler be compiled by Free Pascal Compiler:
  45.   GDB;I386
  46.  
  47.   Required switches for a i386 compiler be compiled by Turbo Pascal:
  48.   GDB;I386;TP
  49.  
  50.   Required switches for a 68000 compiler be compiled by Turbo Pascal:
  51.   GDB;M68k;TP
  52. }
  53.  
  54. {$ifdef FPC}
  55.    {$ifndef GDB}
  56.       {$error The compiler switch GDB must be defined}
  57.    {$endif GDB}
  58.    {$ifndef I386}
  59.       {$ifndef M68K}
  60.         {$error One of the switches I386 or M68K must be defined}
  61.       {$endif M68K}
  62.    {$endif I386}
  63.    {$ifdef support_mmx}
  64.      {$ifndef i386}
  65.        {$error I386 switch must be on}
  66.      {$endif i386}
  67.    {$endif support_mmx}
  68. {$endif}
  69.  
  70. {$ifdef TP}
  71.   {$IFNDEF DPMI}
  72.     {$M 24576,0,655360}
  73.   {$ELSE}
  74.     {$M 49152}
  75.   {$ENDIF DPMI}
  76.   {$E+,N+,F+,S-,R-}
  77. {$endif TP}
  78.  
  79.  
  80. program pp;
  81.  
  82. {$IFDEF TP}
  83.   {$UNDEF PROFILE}
  84.   {$IFDEF DPMI}
  85.     {$UNDEF USEOVERLAY}
  86.   {$ENDIF}
  87. {$ENDIF}
  88. {$ifdef FPC}
  89.   {$UNDEF USEOVERLAY}
  90.   {$UNDEF USEPMD}
  91. {$ENDIF}
  92.  
  93. uses
  94. {$ifdef fpc}
  95.   {$ifdef GO32V2}
  96.     emu387,
  97.     dpmiexcp,
  98.   {$endif GO32V2}
  99. {$endif}
  100. {$ifdef useoverlay}
  101.   {$ifopt o+}
  102.     Overlay,ppovin,
  103.   {$else}
  104.   { warn when not $O+ is used }
  105.     - You must compile with the $O+ switch
  106.   {$endif}
  107. {$endif useoverlay}
  108. {$ifdef lock}
  109.   lock,
  110. {$endif lock}
  111. {$ifdef profile}
  112.   profile,
  113. {$endif profile}
  114. {$ifdef muller}
  115.   openfile,
  116.   {$ifdef usepmd}
  117.     usepmd,
  118.   {$endif usepmd}
  119. {$endif}
  120. {$ifdef LINUX}
  121.   catch,
  122. {$endif LINUX}
  123.   dos,objects,cobjects,
  124.   globals,parser,systems,tree,symtable,options,link,import,files,
  125.   verb_def,verbose;
  126.  
  127. {$ifdef useoverlay}
  128.   {$O files}
  129.   {$O globals}
  130.   {$O hcodegen}
  131.   {$O pass_1}
  132.   {$O tree}
  133.   {$O types}
  134.   {$O objects}
  135.   {$O options}
  136.   {$O cobjects}
  137.   {$O globals}
  138.   {$O systems}
  139.   {$O parser}
  140.   {$O dos}
  141.   {$O scanner}
  142.   {$O symtable}
  143.   {$O objects}
  144.   {$O aasm}
  145.   {$ifdef gdb}
  146.     {$O gdb}
  147.   {$endif gdb}
  148.   {$ifdef i386}
  149.     {$O opts386}
  150.     {$O cgi386}
  151.     {$O aopt386}
  152.     {$O cgai386}
  153.     {$O i386}
  154.     {$O radi386}
  155.     {$O rai386}
  156.     {$O ratti386}
  157.     {$O tgeni386}
  158.   {$endif}
  159.   {$ifdef m68k}
  160.     {$O opts68k}
  161.     {$O cg68k}
  162.     {$O ra68k}
  163.     {$O ag68kgas}
  164.   {$endif}
  165. {$endif useoverlay}
  166.  
  167.  
  168. function print_status(const status : tcompilestatus) : boolean;
  169. begin
  170.   print_status:=false;
  171.   if (abslines=1) then
  172.    Message1(general_i_kb_free,tostr(memavail shr 10));
  173.   if (status.currentline mod 100=0) then
  174.    Message2(general_l_lines_and_free,tostr(status.currentline),tostr(memavail shr 10));
  175. {$ifdef tp}
  176.   if (use_big) then
  177.    begin
  178.    {$ifdef dpmi}
  179.      Message1(general_i_stream_kb_free,tostr(symbolstream.getsize shr 10));
  180.    {$else}
  181.      Message1(general_i_ems_kb_free,tostr(symbolstream.getsize shr 10));
  182.    {$endif}
  183.    end;
  184. {$endif}
  185. end;
  186.  
  187.  
  188. function getrealtime : real;
  189. var
  190.   h,m,s,s100 : word;
  191. begin
  192.   dos.gettime(h,m,s,s100);
  193.   getrealtime:=h*3600.0+m*60.0+s+s100/100.0;
  194. end;
  195.  
  196.  
  197.  
  198. var
  199.   oldexit : pointer;
  200. procedure myexit;{$ifndef FPC}far;{$endif}
  201. begin
  202.   exitproc:=oldexit;
  203. {$ifdef tp}
  204.   if use_big then
  205.    symbolstream.done;
  206. {$endif}
  207.   if (erroraddr<>nil) then
  208.    begin
  209.      case exitcode of
  210.       202 : begin
  211.               erroraddr:=nil;
  212.               Writeln('Error: Stack Overflow');
  213.             end;
  214.       203 : begin
  215.               erroraddr:=nil;
  216.               Writeln('Error: Out of memory');
  217.             end;
  218.      end;
  219.    {when the module is assigned, then the messagefile is also loaded}
  220.      if assigned(current_module) and assigned(current_module^.current_inputfile) then
  221.       Writeln('Compilation aborted at line ',current_module^.current_inputfile^.line_no);
  222.    end;
  223.    { Close all remaining opened files }
  224.    CloseAll;
  225. end;
  226.  
  227.  
  228. {$ifdef tp}
  229.   procedure do_streamerror;
  230.   begin
  231.     if symbolstream.status=-2 then
  232.      WriteLn('Error: Not enough EMS memory')
  233.     else
  234.      WriteLn('Error: EMS Error ',symbolstream.status);
  235.   {$ifndef MULLER}
  236.     halt(1);
  237.   {$else MULLER}
  238.     runerror(190);
  239.   {$endif MULLER}
  240.   end;
  241.  
  242.   {$ifdef USEOVERLAY}
  243.     function _heaperror(size:word):integer;far;
  244.     type
  245.       heaprecord=record
  246.         next:pointer;
  247.         values:longint;
  248.       end;
  249.     var
  250.       l,m:longint;
  251.     begin
  252.       l:=ovrgetbuf-ovrminsize;
  253.       if (size>maxavail) and (l>=size) then
  254.        begin
  255.          m:=((longint(size)+$3fff) and $ffffc000);
  256.          {Clear the overlay buffer.}
  257.          ovrclearbuf;
  258.          {Shrink it.}
  259.          ovrheapend:=ovrheapend-m shr 4;
  260.          heaprecord(ptr(ovrheapend,0)^).next:=freelist;
  261.          heaprecord(ptr(ovrheapend,0)^).values:=m shl 12;
  262.          heaporg:=ptr(ovrheapend,0);
  263.          freelist:=heaporg;
  264.          Writeln('Warning: Overlay buffer shrinked, because of memory shortage');
  265.          _heaperror:=2;
  266.        end
  267.       else
  268.        _heaperror:=0;
  269.     end;
  270.   {$endif USEOVERLAY}
  271. {$endif TP}
  272.  
  273.  
  274.  
  275. var
  276.   start : real;
  277. {$IfDef Extdebug}
  278.   EntryMemAvail : longint;
  279. {$EndIf}
  280. begin
  281.   oldexit:=exitproc;
  282.   exitproc:=@myexit;
  283.  
  284.   start:=getrealtime;
  285. {$ifdef EXTDEBUG}
  286.    EntryMemAvail:=MemAvail;
  287. {$endif}
  288. {$ifdef MULLER}
  289.   {$ifdef DPMI}
  290.      HeapBlock:=$ff00;
  291.   {$endif DPMI}
  292. {$endif MULLER}
  293. {$ifdef TP}
  294.   {$IFDEF USEOVERLAY}
  295.     heaperror:=@_heaperror;
  296.   {$ENDIF USEOVERLAY}
  297.    if use_big then
  298.     begin
  299.       streamerror:=@do_streamerror;
  300.     { symbolstream.init('TMPFILE',stcreate,16000); }
  301.     {$ifndef dpmi}
  302.       symbolstream.init(10000,4000000); {using ems streams}
  303.     {$else}
  304.       symbolstream.init(1000000,16000); {using memory streams}
  305.     {$endif}
  306.       if symbolstream.errorinfo=stiniterror then
  307.        do_streamerror;
  308.     { write something, because pos 0 means nil pointer }
  309.       symbolstream.writestr(@inputfile);
  310.     end;
  311. {$endif tp}
  312.  
  313. {$ifndef TP}
  314.    compilestatusproc:=@print_status;
  315. {$else}
  316.    compilestatusproc:=print_status;
  317. {$endif}
  318.  
  319.    { inits which need to be done  before the arguments are parsed }
  320.    get_exepath;
  321.    init_tree;
  322.    globalsinit;
  323.    init_symtable;
  324.    linker.init;
  325.  
  326.    { read the arguments }
  327.    read_arguments;
  328.  
  329.    { inits which depend on arguments }
  330.    initparser;
  331.    initimport;
  332.  
  333.    {show some info}
  334.    Message1(general_i_compilername,FixFileName(paramstr(0)));
  335.    Message1(general_i_unitsearchpath,unitsearchpath